home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / src / lib / tcl / dist6.3 / tclProc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-01  |  14.4 KB  |  568 lines
  1. /* 
  2.  * tclProc.c --
  3.  *
  4.  *    This file contains routines that implement Tcl procedures,
  5.  *    including the "proc" and "uplevel" commands.
  6.  *
  7.  * Copyright 1987-1991 Regents of the University of California
  8.  * Permission to use, copy, modify, and distribute this
  9.  * software and its documentation for any purpose and without
  10.  * fee is hereby granted, provided that the above copyright
  11.  * notice appear in all copies.  The University of California
  12.  * makes no representations about the suitability of this
  13.  * software for any purpose.  It is provided "as is" without
  14.  * express or implied warranty.
  15.  */
  16.  
  17. #ifndef lint
  18. static char rcsid[] = "$Header: /sprite/src/lib/tcl/RCS/tclProc.c,v 1.59 91/09/30 16:59:54 ouster Exp $ SPRITE (Berkeley)";
  19. #endif
  20.  
  21. #include "tclInt.h"
  22.  
  23. /*
  24.  * Forward references to procedures defined later in this file:
  25.  */
  26.  
  27. static  int    InterpProc _ANSI_ARGS_((ClientData clientData,
  28.             Tcl_Interp *interp, int argc, char **argv));
  29. static  void    ProcDeleteProc _ANSI_ARGS_((ClientData clientData));
  30.  
  31. /*
  32.  *----------------------------------------------------------------------
  33.  *
  34.  * Tcl_ProcCmd --
  35.  *
  36.  *    This procedure is invoked to process the "proc" Tcl command.
  37.  *    See the user documentation for details on what it does.
  38.  *
  39.  * Results:
  40.  *    A standard Tcl result value.
  41.  *
  42.  * Side effects:
  43.  *    A new procedure gets created.
  44.  *
  45.  *----------------------------------------------------------------------
  46.  */
  47.  
  48.     /* ARGSUSED */
  49. int
  50. Tcl_ProcCmd(dummy, interp, argc, argv)
  51.     ClientData dummy;            /* Not used. */
  52.     Tcl_Interp *interp;            /* Current interpreter. */
  53.     int argc;                /* Number of arguments. */
  54.     char **argv;            /* Argument strings. */
  55. {
  56.     register Interp *iPtr = (Interp *) interp;
  57.     register Proc *procPtr;
  58.     int result, argCount, i;
  59.     char **argArray = NULL;
  60.     Arg *lastArgPtr;
  61.     register Arg *argPtr = NULL;    /* Initialization not needed, but
  62.                      * prevents compiler warning. */
  63.  
  64.     if (argc != 4) {
  65.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  66.         " name args body\"", (char *) NULL);
  67.     return TCL_ERROR;
  68.     }
  69.  
  70.     procPtr = (Proc *) ckalloc(sizeof(Proc));
  71.     procPtr->iPtr = iPtr;
  72.     procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1);
  73.     strcpy(procPtr->command, argv[3]);
  74.     procPtr->argPtr = NULL;
  75.  
  76.     /*
  77.      * Break up the argument list into argument specifiers, then process
  78.      * each argument specifier.
  79.      */
  80.  
  81.     result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);
  82.     if (result != TCL_OK) {
  83.     goto procError;
  84.     }
  85.     lastArgPtr = NULL;
  86.     for (i = 0; i < argCount; i++) {
  87.     int fieldCount, nameLength, valueLength;
  88.     char **fieldValues;
  89.  
  90.     /*
  91.      * Now divide the specifier up into name and default.
  92.      */
  93.  
  94.     result = Tcl_SplitList(interp, argArray[i], &fieldCount,
  95.         &fieldValues);
  96.     if (result != TCL_OK) {
  97.         goto procError;
  98.     }
  99.     if (fieldCount > 2) {
  100.         ckfree((char *) fieldValues);
  101.         Tcl_AppendResult(interp,
  102.             "too many fields in argument specifier \"",
  103.             argArray[i], "\"", (char *) NULL);
  104.         result = TCL_ERROR;
  105.         goto procError;
  106.     }
  107.     if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
  108.         ckfree((char *) fieldValues);
  109.         Tcl_AppendResult(interp, "procedure \"", argv[1],
  110.             "\" has argument with no name", (char *) NULL);
  111.         result = TCL_ERROR;
  112.         goto procError;
  113.     }
  114.     nameLength = strlen(fieldValues[0]) + 1;
  115.     if (fieldCount == 2) {
  116.         valueLength = strlen(fieldValues[1]) + 1;
  117.     } else {
  118.         valueLength = 0;
  119.     }
  120.     argPtr = (Arg *) ckalloc((unsigned)
  121.         (sizeof(Arg) - sizeof(argPtr->name) + nameLength
  122.         + valueLength));
  123.     if (lastArgPtr == NULL) {
  124.         procPtr->argPtr = argPtr;
  125.     } else {
  126.         lastArgPtr->nextPtr = argPtr;
  127.     }
  128.     lastArgPtr = argPtr;
  129.     argPtr->nextPtr = NULL;
  130.     strcpy(argPtr->name, fieldValues[0]);
  131.     if (fieldCount == 2) {
  132.         argPtr->defValue = argPtr->name + nameLength;
  133.         strcpy(argPtr->defValue, fieldValues[1]);
  134.     } else {
  135.         argPtr->defValue = NULL;
  136.     }
  137.     ckfree((char *) fieldValues);
  138.     }
  139.  
  140.     Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr,
  141.         ProcDeleteProc);
  142.     ckfree((char *) argArray);
  143.     return TCL_OK;
  144.  
  145.     procError:
  146.     ckfree(procPtr->command);
  147.     while (procPtr->argPtr != NULL) {
  148.     argPtr = procPtr->argPtr;
  149.     procPtr->argPtr = argPtr->nextPtr;
  150.     ckfree((char *) argPtr);
  151.     }
  152.     ckfree((char *) procPtr);
  153.     if (argArray != NULL) {
  154.     ckfree((char *) argArray);
  155.     }
  156.     return result;
  157. }
  158.  
  159. /*
  160.  *----------------------------------------------------------------------
  161.  *
  162.  * TclGetFrame --
  163.  *
  164.  *    Given a description of a procedure frame, such as the first
  165.  *    argument to an "uplevel" or "upvar" command, locate the
  166.  *    call frame for the appropriate level of procedure.
  167.  *
  168.  * Results:
  169.  *    The return value is -1 if an error occurred in finding the
  170.  *    frame (in this case an error message is left in interp->result).
  171.  *    1 is returned if string was either a number or a number preceded
  172.  *    by "#" and it specified a valid frame.  0 is returned if string
  173.  *    isn't one of the two things above (in this case, the lookup
  174.  *    acts as if string were "1").  The variable pointed to by
  175.  *    framePtrPtr is filled in with the address of the desired frame
  176.  *    (unless an error occurs, in which case it isn't modified).
  177.  *
  178.  * Side effects:
  179.  *    None.
  180.  *
  181.  *----------------------------------------------------------------------
  182.  */
  183.  
  184. int
  185. TclGetFrame(interp, string, framePtrPtr)
  186.     Tcl_Interp *interp;        /* Interpreter in which to find frame. */
  187.     char *string;        /* String describing frame. */
  188.     CallFrame **framePtrPtr;    /* Store pointer to frame here (or NULL
  189.                  * if global frame indicated). */
  190. {
  191.     register Interp *iPtr = (Interp *) interp;
  192.     int level, result;
  193.     CallFrame *framePtr;
  194.  
  195.     if (iPtr->varFramePtr == NULL) {
  196.     iPtr->result = "already at top level";
  197.     return -1;
  198.     }
  199.  
  200.     /*
  201.      * Parse string to figure out which level number to go to.
  202.      */
  203.  
  204.     result = 1;
  205.     if (*string == '#') {
  206.     if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
  207.         return -1;
  208.     }
  209.     if (level < 0) {
  210.         levelError:
  211.         Tcl_AppendResult(interp, "bad level \"", string, "\"",
  212.             (char *) NULL);
  213.         return -1;
  214.     }
  215.     } else if (isdigit(*string)) {
  216.     if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
  217.         return -1;
  218.     }
  219.     level = iPtr->varFramePtr->level - level;
  220.     } else {
  221.     level = iPtr->varFramePtr->level - 1;
  222.     result = 0;
  223.     }
  224.  
  225.     /*
  226.      * Figure out which frame to use, and modify the interpreter so
  227.      * its variables come from that frame.
  228.      */
  229.  
  230.     if (level == 0) {
  231.     framePtr = NULL;
  232.     } else {
  233.     for (framePtr = iPtr->varFramePtr; framePtr != NULL;
  234.         framePtr = framePtr->callerVarPtr) {
  235.         if (framePtr->level == level) {
  236.         break;
  237.         }
  238.     }
  239.     if (framePtr == NULL) {
  240.         goto levelError;
  241.     }
  242.     }
  243.     *framePtrPtr = framePtr;
  244.     return result;
  245. }
  246.  
  247. /*
  248.  *----------------------------------------------------------------------
  249.  *
  250.  * Tcl_UplevelCmd --
  251.  *
  252.  *    This procedure is invoked to process the "uplevel" Tcl command.
  253.  *    See the user documentation for details on what it does.
  254.  *
  255.  * Results:
  256.  *    A standard Tcl result value.
  257.  *
  258.  * Side effects:
  259.  *    See the user documentation.
  260.  *
  261.  *----------------------------------------------------------------------
  262.  */
  263.  
  264.     /* ARGSUSED */
  265. int
  266. Tcl_UplevelCmd(dummy, interp, argc, argv)
  267.     ClientData dummy;            /* Not used. */
  268.     Tcl_Interp *interp;            /* Current interpreter. */
  269.     int argc;                /* Number of arguments. */
  270.     char **argv;            /* Argument strings. */
  271. {
  272.     register Interp *iPtr = (Interp *) interp;
  273.     int result;
  274.     CallFrame *savedVarFramePtr, *framePtr;
  275.  
  276.     if (argc < 2) {
  277.     uplevelSyntax:
  278.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  279.         " ?level? command ?command ...?\"", (char *) NULL);
  280.     return TCL_ERROR;
  281.     }
  282.  
  283.     /*
  284.      * Find the level to use for executing the command.
  285.      */
  286.  
  287.     result = TclGetFrame(interp, argv[1], &framePtr);
  288.     if (result == -1) {
  289.     return TCL_ERROR;
  290.     }
  291.     argc -= (result+1);
  292.     argv += (result+1);
  293.  
  294.     /*
  295.      * Modify the interpreter state to execute in the given frame.
  296.      */
  297.  
  298.     savedVarFramePtr = iPtr->varFramePtr;
  299.     iPtr->varFramePtr = framePtr;
  300.  
  301.     /*
  302.      * Execute the residual arguments as a command.
  303.      */
  304.  
  305.     if (argc == 0) {
  306.     goto uplevelSyntax;
  307.     }
  308.     if (argc == 1) {
  309.     result = Tcl_Eval(interp, argv[0], 0, (char **) NULL);
  310.     } else {
  311.     char *cmd;
  312.  
  313.     cmd = Tcl_Concat(argc, argv);
  314.     result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
  315.     ckfree(cmd);
  316.     }
  317.     if (result == TCL_ERROR) {
  318.     char msg[60];
  319.     sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
  320.     Tcl_AddErrorInfo(interp, msg);
  321.     }
  322.  
  323.     /*
  324.      * Restore the variable frame, and return.
  325.      */
  326.  
  327.     iPtr->varFramePtr = savedVarFramePtr;
  328.     return result;
  329. }
  330.  
  331. /*
  332.  *----------------------------------------------------------------------
  333.  *
  334.  * TclFindProc --
  335.  *
  336.  *    Given the name of a procedure, return a pointer to the
  337.  *    record describing the procedure.
  338.  *
  339.  * Results:
  340.  *    NULL is returned if the name doesn't correspond to any
  341.  *    procedure.  Otherwise the return value is a pointer to
  342.  *    the procedure's record.
  343.  *
  344.  * Side effects:
  345.  *    None.
  346.  *
  347.  *----------------------------------------------------------------------
  348.  */
  349.  
  350. Proc *
  351. TclFindProc(iPtr, procName)
  352.     Interp *iPtr;        /* Interpreter in which to look. */
  353.     char *procName;        /* Name of desired procedure. */
  354. {
  355.     Tcl_HashEntry *hPtr;
  356.     Command *cmdPtr;
  357.  
  358.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName);
  359.     if (hPtr == NULL) {
  360.     return NULL;
  361.     }
  362.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  363.     if (cmdPtr->proc != InterpProc) {
  364.     return NULL;
  365.     }
  366.     return (Proc *) cmdPtr->clientData;
  367. }
  368.  
  369. /*
  370.  *----------------------------------------------------------------------
  371.  *
  372.  * TclIsProc --
  373.  *
  374.  *    Tells whether a command is a Tcl procedure or not.
  375.  *
  376.  * Results:
  377.  *    If the given command is actuall a Tcl procedure, the
  378.  *    return value is the address of the record describing
  379.  *    the procedure.  Otherwise the return value is 0.
  380.  *
  381.  * Side effects:
  382.  *    None.
  383.  *
  384.  *----------------------------------------------------------------------
  385.  */
  386.  
  387. Proc *
  388. TclIsProc(cmdPtr)
  389.     Command *cmdPtr;        /* Command to test. */
  390. {
  391.     if (cmdPtr->proc == InterpProc) {
  392.     return (Proc *) cmdPtr->clientData;
  393.     }
  394.     return (Proc *) 0;
  395. }
  396.  
  397. /*
  398.  *----------------------------------------------------------------------
  399.  *
  400.  * InterpProc --
  401.  *
  402.  *    When a Tcl procedure gets invoked, this routine gets invoked
  403.  *    to interpret the procedure.
  404.  *
  405.  * Results:
  406.  *    A standard Tcl result value, usually TCL_OK.
  407.  *
  408.  * Side effects:
  409.  *    Depends on the commands in the procedure.
  410.  *
  411.  *----------------------------------------------------------------------
  412.  */
  413.  
  414. static int
  415. InterpProc(clientData, interp, argc, argv)
  416.     ClientData clientData;    /* Record describing procedure to be
  417.                  * interpreted. */
  418.     Tcl_Interp *interp;        /* Interpreter in which procedure was
  419.                  * invoked. */
  420.     int argc;            /* Count of number of arguments to this
  421.                  * procedure. */
  422.     char **argv;        /* Argument values. */
  423. {
  424.     register Proc *procPtr = (Proc *) clientData;
  425.     register Arg *argPtr;
  426.     register Interp *iPtr = (Interp *) interp;
  427.     char **args;
  428.     CallFrame frame;
  429.     char *value, *end;
  430.     int result;
  431.  
  432.     /*
  433.      * Set up a call frame for the new procedure invocation.
  434.      */
  435.  
  436.     iPtr = procPtr->iPtr;
  437.     Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
  438.     if (iPtr->varFramePtr != NULL) {
  439.     frame.level = iPtr->varFramePtr->level + 1;
  440.     } else {
  441.     frame.level = 1;
  442.     }
  443.     frame.argc = argc;
  444.     frame.argv = argv;
  445.     frame.callerPtr = iPtr->framePtr;
  446.     frame.callerVarPtr = iPtr->varFramePtr;
  447.     iPtr->framePtr = &frame;
  448.     iPtr->varFramePtr = &frame;
  449.  
  450.     /*
  451.      * Match the actual arguments against the procedure's formal
  452.      * parameters to compute local variables.
  453.      */
  454.  
  455.     for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1;
  456.         argPtr != NULL;
  457.         argPtr = argPtr->nextPtr, args++, argc--) {
  458.  
  459.     /*
  460.      * Handle the special case of the last formal being "args".  When
  461.      * it occurs, assign it a list consisting of all the remaining
  462.      * actual arguments.
  463.      */
  464.  
  465.     if ((argPtr->nextPtr == NULL)
  466.         && (strcmp(argPtr->name, "args") == 0)) {
  467.         if (argc < 0) {
  468.         argc = 0;
  469.         }
  470.         value = Tcl_Merge(argc, args);
  471.         Tcl_SetVar(interp, argPtr->name, value, 0);
  472.         ckfree(value);
  473.         argc = 0;
  474.         break;
  475.     } else if (argc > 0) {
  476.         value = *args;
  477.     } else if (argPtr->defValue != NULL) {
  478.         value = argPtr->defValue;
  479.     } else {
  480.         Tcl_AppendResult(interp, "no value given for parameter \"",
  481.             argPtr->name, "\" to \"", argv[0], "\"",
  482.             (char *) NULL);
  483.         result = TCL_ERROR;
  484.         goto procDone;
  485.     }
  486.     Tcl_SetVar(interp, argPtr->name, value, 0);
  487.     }
  488.     if (argc > 0) {
  489.     Tcl_AppendResult(interp, "called \"", argv[0],
  490.         "\" with too many arguments", (char *) NULL);
  491.     result = TCL_ERROR;
  492.     goto procDone;
  493.     }
  494.  
  495.     /*
  496.      * Invoke the commands in the procedure's body.
  497.      */
  498.  
  499.     result = Tcl_Eval(interp, procPtr->command, 0, &end);
  500.     if (result == TCL_RETURN) {
  501.     result = TCL_OK;
  502.     } else if (result == TCL_ERROR) {
  503.     char msg[100];
  504.  
  505.     /*
  506.      * Record information telling where the error occurred.
  507.      */
  508.  
  509.     sprintf(msg, "\n    (procedure \"%.50s\" line %d)", argv[0],
  510.         iPtr->errorLine);
  511.     Tcl_AddErrorInfo(interp, msg);
  512.     } else if (result == TCL_BREAK) {
  513.     iPtr->result = "invoked \"break\" outside of a loop";
  514.     result = TCL_ERROR;
  515.     } else if (result == TCL_CONTINUE) {
  516.     iPtr->result = "invoked \"continue\" outside of a loop";
  517.     result = TCL_ERROR;
  518.     }
  519.  
  520.     /*
  521.      * Delete the call frame for this procedure invocation (it's
  522.      * important to remove the call frame from the interpreter
  523.      * before deleting it, so that traces invoked during the
  524.      * deletion don't see the partially-deleted frame).
  525.      */
  526.  
  527.     procDone:
  528.     iPtr->framePtr = frame.callerPtr;
  529.     iPtr->varFramePtr = frame.callerVarPtr;
  530.     TclDeleteVars(iPtr, &frame.varTable);
  531.     return result;
  532. }
  533.  
  534. /*
  535.  *----------------------------------------------------------------------
  536.  *
  537.  * ProcDeleteProc --
  538.  *
  539.  *    This procedure is invoked just before a command procedure is
  540.  *    removed from an interpreter.  Its job is to release all the
  541.  *    resources allocated to the procedure.
  542.  *
  543.  * Results:
  544.  *    None.
  545.  *
  546.  * Side effects:
  547.  *    Memory gets freed.
  548.  *
  549.  *----------------------------------------------------------------------
  550.  */
  551.  
  552. static void
  553. ProcDeleteProc(clientData)
  554.     ClientData clientData;        /* Procedure to be deleted. */
  555. {
  556.     register Proc *procPtr = (Proc *) clientData;
  557.     register Arg *argPtr;
  558.  
  559.     ckfree((char *) procPtr->command);
  560.     for (argPtr = procPtr->argPtr; argPtr != NULL; ) {
  561.     Arg *nextPtr = argPtr->nextPtr;
  562.  
  563.     ckfree((char *) argPtr);
  564.     argPtr = nextPtr;
  565.     }
  566.     ckfree((char *) procPtr);
  567. }
  568.